package netDraw;

#------------------------------------------------------------------------------
# Author:  Marelie Davel (marelie.davel@gmail.com)
#------------------------------------------------------------------------------

use Graph;

use warnings;
use strict;

#------------------------------------------------------------------------------

BEGIN {
  # Global vars
  my $debug = 0;
  my %pcolors = ('1'=>'blue','2'=>'brown','3'=>'green','4'=>'cyan','5'=>'black','6'=>'red', 7=>'orange',8=>'magenta',9=>'yellow');
  
  use Exporter();
  use vars qw(@EXPORT @ISA);
  @ISA = qw(Exporter);
  @EXPORT = qw(&fdraw_rule_net &fdraw_class_net $debug);
}

#------------------------------------------------------------------------------
# Node helper functions
#------------------------------------------------------------------------------

sub get_name($\%) {
  my ($name,$symbolsP) = @_;
  if (! exists $symbolsP->{$name}) {
    die "Error: unknown symbol [$name]";
  }
  return $symbolsP->{$name};
}
  
sub get_outcome($$) {
  my ($gtreep,$v) = @_;
  #print "Entering get_outcome: [$v]\n" if $netDraw::debug; 
  my $out;
  if (!($$gtreep->has_attribute('outcome',$v))) {
    die "Error: node [$v] does not have an outcome";
  } else {
    $out=$$gtreep->get_attribute('outcome',$v);
  }
  return $out;
}

sub get_left($$) {
  my ($gtreep,$v) = @_;
  #print "Entering get_left: [$v]\n" if $netDraw::debug; 
  my $out;
  if (!($$gtreep->has_attribute('left',$v))) {
    die "Error: node [$v] does not have a left value";
  } else {
    $out=$$gtreep->get_attribute('left',$v);
  }
  return $out;
}

sub get_right($$) {
  my ($gtreep,$v) = @_;
  #print "Entering get_right: [$v]\n" if $netDraw::debug; 
  my $out;
  if (!($$gtreep->has_attribute('right',$v))) {
    die "Error: node [$v] does not have a right value";
  } else {
    $out=$$gtreep->get_attribute('right',$v);
  }
  return $out;
}

sub get_rank($$) {
  my ($gtreep,$v) = @_;
  #print "Entering get_rank: [$v]\n" if $netDraw::debug; 
  my $out;
  if (!($$gtreep->has_attribute('rank',$v))) {
    die "Error: node [$v] does not have a rank value";
  } else {
    $out=$$gtreep->get_attribute('rank',$v);
  }
  return $out;
}

sub get_vtype($$) {
  my ($gtreep,$v) = @_;
  #print "Entering get_vtype: [$v]\n" if $netDraw::debug; 
  my $out;
  if (!($$gtreep->has_attribute('vtype',$v))) {
    die "Error: node [$v] does not have a vtype";
  } else {
    $out=$$gtreep->get_attribute('vtype',$v);
  }
  return $out;
}

sub get_count($$) {
  my ($gtreep,$v) = @_;
  #print "Entering get_count: [$v]\n" if $netDraw::debug; 
  my $out;
  if (!($$gtreep->has_attribute('count',$v))) {
    die "Error: node [$v] does not have a count";
  } else {
    $out=$$gtreep->get_attribute('count',$v);
  }
  return $out;
}

sub get_examples($$) {
  my ($gtreep,$v) = @_;
  #print "Entering get_examples: [$v]\n" if $netDraw::debug; 
  my $out;
  if (!($$gtreep->has_attribute('eg_str',$v))) {
    die "Error: node [$v] does not have an eg_str";
  } else {
    $out=$$gtreep->get_attribute('eg_str',$v);
  }
  return $out;
}

#------------------------------------------------------------------------------
# Net create functions
#------------------------------------------------------------------------------

sub add_node_to_net($$$$);
sub add_node_here($$$$);

sub add_node_to_net($$$$) {
  my ($gtreep,$root,$rule,$outcome) = @_;
  #print "Entering add_node_to_net: [$root][$rule][$outcome]\n" if $netDraw::debug;
  my $root_right =get_right($gtreep,$root);
  if (($rule !~ /$root_right$/)&&(!($root eq "default"))) {    #CHECK
    #print "opting out: [$rule] does not match root [$root]\n";
    return 0;
  } else {
    #print "opting in: [$rule] does match root [$root]\n";
  }
  my @nodeList = $$gtreep->successors($root);
  my %results=();
  foreach my $node (@nodeList) {
    $results{$node} = add_node_to_net($gtreep,$node,$rule,$outcome);
  }
  foreach my $r (keys %results) {
    if ($results{$r}==1) {
      return 1;
    }
  }
  return add_node_here($gtreep,$root,$rule,$outcome);
}

#------------------------------------------------------------------------------

sub add_node_here($$$$) {
  my ($gtreep,$root,$rule,$outcome) = @_;
  #print "Entering add_node_here: [$root][$rule][$outcome]\n" if $netDraw::debug;
  my @outcomes = split /,/,$outcome;
  my ($name,$left,$right);
  if (scalar @outcomes > 1) {
    $name = $rule;
    $left = "unset";
    $right = "unset";
  } else {
    $name = $outcome;
    my $i = index $name,">";
    $left = substr($name,0,$i);
    $right = substr($name,$i+1);
  }
  if ($$gtreep->has_edge($root,$name)==0) {
    $$gtreep->add_edge($root,$name);
    #print "Adding edge: $root -> $name [$outcome]\n" if $netDraw::debug;
    $$gtreep->set_attribute('outcome',$name,$outcome);
    $$gtreep->set_attribute('vtype',$name,'standard');
    $$gtreep->set_attribute('right',$name,$right);
    $$gtreep->set_attribute('left',$name,$left);
    return 1;
  } else {
    print "Warning: trying to add more than one similar edge\n";
    return 0;
  }
}

#------------------------------------------------------------------------------

sub fread_class_net($$) {
  my ($symbolsName,$gtreep) = @_;
  print "Entering fread_class_net: [$symbolsName]\n" if $netDraw::debug; 
  open SH, "$symbolsName" or die "Error opening $symbolsName\n";
  my %symbols=();         # symbols{y}{xRy}
  while (<SH>) {
    chomp;
    my @parts = split "\t";
    if (scalar @parts != 2) {
      die "Error reading symbols: file $symbolsName, line [$_]";
    }
    my @classParts = split ">",$parts[0];
    if ((scalar @classParts < 1)||(scalar @classParts > 2)) {
      my $numParts = scalar @classParts;
      die "Error reading symbols: file $symbolsName, line [$_][@classParts][$numParts]";
    }
    $symbols{$classParts[1]}{$parts[0]}=1;
  }
  if (! exists $symbols{""}) {
    $symbols{""}{""}=1;
  }
  close SH;
  
  my $numSymbols=0;
  my $root="";
  foreach my $s (sort{length $a<=>length $b} keys %symbols) {
    my @classList = keys %{$symbols{$s}};
    my $outcome = join ",",@classList;
    if ($s eq $root) {
      if ($$gtreep->has_vertex($root)==0) {
        print "Adding node: $root\n" if $netDraw::debug;
        $$gtreep->add_vertex($root);                                         # xRy or y if multiple
        $$gtreep->set_attribute('outcome',$root,$outcome);    #xRy or x1Ry1,x2Ry2,x3Ry3,... if multiple
        $$gtreep->set_attribute('vtype',$root,'standard');          # standard, kid,container
        $$gtreep->set_attribute('right',$root,$root);                   # y
        $$gtreep->set_attribute('left',$root,$root);                     # x
        $$gtreep->set_attribute('eg_str',$root,'');                       # base word \l | baseword2 \l ...
        $$gtreep->set_attribute('count',$root,0);                            #number of positive examples
        $numSymbols++;
      } else {
        print "Warning: trying to add more than one default rule\n";
      }
    } else {
      if (add_node_to_net($gtreep,$root,$s,$outcome)==1) {
        $numSymbols++;
      } else {
        print "Warning: node $s not added\n";
      }
    }
  }
  return $numSymbols;
}

#------------------------------------------------------------------------------
# Rule graph create functions
#------------------------------------------------------------------------------

sub add_rnode_to_net($$$$);
sub add_rnode_here($$$$);

sub add_rnode_to_net($$$$) {
  my ($gtreep,$root,$rule,$outcome) = @_;
  #print "Entering add_node_to_net: [$root][$rule][$outcome]\n" if $netDraw::debug;
  my $root_left =get_left($gtreep,$root);
  if (($rule !~ /$root_left$/)&&(!($root eq ''))) { 
    #print "opting out: [$rule] does not match root [$root]\n";
    return 0;
  } else {
    #print "opting in: [$rule] does match root [$root]\n";
  }
  my @nodeList = $$gtreep->successors($root);
  my %results=();
  foreach my $node (@nodeList) {
    $results{$node} = add_rnode_to_net($gtreep,$node,$rule,$outcome);
  }
  foreach my $r (keys %results) {
    if ($results{$r}==1) {
      return 1;
    }
  }
  return add_rnode_here($gtreep,$root,$rule,$outcome);
}

#------------------------------------------------------------------------------

sub add_rnode_here($$$$) {
  my ($gtreep,$root,$name,$outcome) = @_;
  #print "Entering add_node_here: [$root][$name][$outcome]\n" if $netDraw::debug;
  
  if ($$gtreep->has_edge($root,$name)==0) {
    $$gtreep->add_edge($root,$name);
    #print "Adding edge: $root -> $name [$outcome]\n" if $netDraw::debug;
    $$gtreep->set_attribute('outcome',$name,$outcome);
    $$gtreep->set_attribute('vtype',$name,'standard');
    $$gtreep->set_attribute('right',$name,$outcome);
    $$gtreep->set_attribute('left',$name,$name);
    $$gtreep->set_attribute('count',$name,0);
    return 1;
  } else {
    print "Warning: trying to add more than one similar edge\n";
    return 0;
  }
}

#------------------------------------------------------------------------------

sub update_type($$) {
  my ($gtreep,$vtype) = @_;
  my @all_vertices =$$gtreep->vertices();
  while ((scalar @all_vertices)>0) {
    my $name = shift @all_vertices;
    $$gtreep->set_attribute('vtype',$name,$vtype);
  }  
}

#------------------------------------------------------------------------------

sub fread_rules_net($$$) {
  my ($rulesName,$symbolsName,$gtreep) = @_;
  print "Entering fread_rules_net: [$rulesName][$symbolsName]\n" if $netDraw::debug; 
  open RH, "$rulesName" or die "Error opening $rulesName\n";
  open SH, "$symbolsName" or die "Error opening $symbolsName\n";
  my %symbols=();
  while (<SH>) {
    chomp;
    my @parts = split "\t";
    if (scalar @parts != 2) {
      die "Error reading symbols: file $symbolsName, line [$_]";
    }
    $symbols{$parts[1]}=$parts[0];
  }
    my $root='';
  my $numRules=0;
  while (<RH>) {
    chomp;
    s/ /\#/g;
    my @parts = split ";";
    if (scalar @parts != 6) {
      die "Error reading rules: file $rulesName, line [$_]";
    }
    my $outcome = get_name($parts[3],%symbols);
    my $rule = $parts[1];
    if ($rule eq "") {
      $rule = $root;
      if ($$gtreep->has_vertex($rule)==0) {
        print "Adding node: $rule\n" if $netDraw::debug;
        $$gtreep->add_vertex($rule);
        $$gtreep->set_attribute('outcome',$rule,$outcome);
        $$gtreep->set_attribute('vtype',$rule,'standard');
        $$gtreep->set_attribute('left',$rule,$rule);
        $$gtreep->set_attribute('count',$rule,0);
        $numRules++;
      } else {
        print "Warning: trying to add more than one default rule\n";
      }
    } else {
      if (add_rnode_to_net($gtreep,$root,$rule,$outcome)==1) {
        $numRules++;
      } else {
        print "Warning: node $rule not added\n";
      } 
    }
  }
  return $numRules;
}


#------------------------------------------------------------------------------
# Net manipulation functions
#------------------------------------------------------------------------------

sub add_rule_counts($$) {
  my ($infoName,$gtreep)=@_;
  open IH, "$infoName" or die "Error opening $infoName\n";
  my %counts=();
  while (<IH>) {
    chomp;
    my @parts = split /\t/,$_;
    if (scalar @parts != 3) {
      die "Error in info file format. File: $infoName, Line: $_\n";
    } else {
      $counts{$parts[1]}{$parts[0]}=1;
    }
  }
  close IH;
  my @allVertices = $$gtreep->vertices();
  foreach my $v (@allVertices) {
    my $outcome = get_outcome($gtreep,$v);
    my $left = get_left($gtreep,$v);
    if (! exists $counts{$outcome}) {
      die "Error: no count for class [$outcome]";
    } else {
      my $num=0;
      foreach my $example (keys %{$counts{$outcome}}) {
        $left =~ s/#/ /g;
        if ($example =~ /$left$/) {
          $num++;
        }
      }
      $$gtreep->set_attribute('count',$v,$num);
    }
  }
}

#------------------------------------------------------------------------------

sub find_largest_matching_str(\%) {
  my $listP = shift @_;
  #print "Entering find_largest_matching_str\n" if $netDraw::debug; 
  my $winner = "";
  my $possible = "";
  my $is_possible = 1;
  my $keep_w;
  while ($is_possible==1) {
    foreach my $w (keys %$listP) {
      $keep_w = "$w";
      if ($w !~ /$possible$/) {
        $is_possible=0;
        last;
      }
    }
    if ($is_possible == 1) {
      $winner=$possible;
      my $len = length $winner;
      $possible = substr($keep_w,-$len-1,$len+1);
      if ($winner eq $keep_w) {
        $is_possible=0;
      }
    }
  }
  #print "Leaving find_largest_matching_str: [$winner]\n" if $netDraw::debug; 
  return $winner;
}

#------------------------------------------------------------------------------

sub find_matching_set(\%$\%) {
  my ($wordP,$possibleBest,$matchWordP)=@_;
  my $found=0;
  foreach my $w (keys %{$wordP}) {
    if ($w =~ /$possibleBest$/) {
      $matchWordP->{$w}=1;
      $found=1;
    }
  }
 return $found;
}

#------------------------------------------------------------------------------

sub create_clusters(\%\%\%) {
  my ($derivP,$clusterP,$bestP) = @_;
  # Using the info in $derivP, create the structue $clusterP->{class}{bestStr}{deriv}
  # such that each deriv matches bestStr and
  # no larger bestStr can be extracted for a set of words in deriv

  #Create initial data structure
  foreach my $c (keys %{$derivP}) {
    my %words = ();
    foreach my $w (keys %{$derivP->{$c}}) {
      $words{$w}=1;
    }
    my $bestStr = find_largest_matching_str(%words);
    $bestP->{$bestStr}=1;
    foreach my $w (keys %words) {
      $clusterP->{$c}{$bestStr}{$w}=1;
    }
  }
  
  #Split word lists further if possible
  my %checkBest=();
  foreach my $c (keys %{$clusterP}) {
    foreach my $currentBest (keys %{$clusterP->{$c}}) {
      my %words = ();
      foreach my $w (keys %{$clusterP->{$c}{$currentBest}}) {
        $words{$w}=1;
      }
      foreach my $possibleBest (sort { length $b <=> length $a} keys %{$bestP})  {
        if (length $possibleBest > length $currentBest) {
          my %matchWords=();
          if (find_matching_set(%words,$possibleBest,%matchWords)==1) {  
            print "HERE: removing a subset from [$c] with [$currentBest] in favour of [$possibleBest]\n";
            foreach my $mw (keys %matchWords) {
              #move words to new string
              $clusterP->{$c}{$possibleBest}{$mw}=1;
              delete $clusterP->{$c}{$currentBest}{$mw};
              delete $words{$mw};
            }  
            #and remove references to previous string, if necessary
            my @remainingWords = keys %{$clusterP->{$c}{$currentBest}};
            if (scalar @remainingWords == 0) {
              delete $clusterP->{$c}{$currentBest};
              $checkBest{$currentBest}=1;
            }
          }
        }
      }
    }
  }
  #Remove unnecessary strings from $bestP
  foreach my $b (keys %checkBest) {
    my $found=0;
    foreach my $c (keys %{$clusterP}) {
      if (exists $clusterP->{$c}{$b}) {
        $found=1;
      }
    }
    if ($found==0) {
      delete $bestP->{$b};
    }
  }
  # TODO: Change to iterative process by adding stopping criteria - or manually edit to match data requirements
  # TODO: For current data one iteration fine - can imagine different data sets may have different requirements
}

sub add_new_node($$$$$) {
  my ($gtreeP,$root,$v,$left,$right) = @_;
  print "Entering add_new_node: [$root] -> [$v]\n" if $netDraw::debug;
  if ($$gtreeP->has_vertex($v)) {
    die "Error: adding a node that already exists [$v]";
  }
  $$gtreeP->add_vertex($v);
  $$gtreeP->set_attribute('vtype',$v,'standard');
  $$gtreeP->set_attribute('outcome',$v,"$left>$right");
  $$gtreeP->set_attribute('left',$v,$left);
  $$gtreeP->set_attribute('right',$v,$right);
  $$gtreeP->set_attribute('count',$v,0);
  $$gtreeP->set_attribute('eg_str',$v,'');
  
  if ($$gtreeP->has_edge($root,$v)) {
    die "Error: adding an edge that already exists [$v]";
  }
  $$gtreeP->add_edge($root,$v);
}

sub add_branch($$\%\%) {
  my ($gtreeP,$bestStr,$classP,$clusterP)=@_;
  #Add the >$bestStr branch to gtreeP
  #based on the list of classes in $classP
  print "Entering add_branch: [$bestStr]\n" if $netDraw::debug; 
  
  #Get possible y-options
  my %ylist=();
  foreach my $c (keys %{$classP}) {  
    my @parts = split />/,$c;
    if (scalar @parts == 2) {
      $ylist{"$parts[1]"} = 1;
    } else {
     die "Error:format error in class name: $c";
    }
  }
      
  #First add R>bestStr
  my $root='';
  my $mainName = "R>$bestStr";
  my $mainNode = "$bestStr:$mainName";
 print "HERE adding first node\n";
  add_new_node($gtreeP,$root,$mainNode,"R",$bestStr);
  if ((! exists $clusterP->{$mainName}) || (! exists $clusterP->{$mainName}{$bestStr})) {
    $clusterP->{$mainName}{$bestStr} = ();
  }
  
  #Then add other R>y
  foreach my $y (sort keys %ylist) {
    next if $y eq $bestStr;
    my $newName = "R>$y";
    my $newNode = "$bestStr:$newName";
    print "HERE adding second tier [$y] to [$bestStr]\n";
    add_new_node($gtreeP,$mainNode,$newNode,"R",$y);
    if ((! exists $clusterP->{$newName}) || (! exists $clusterP->{$newName}{$bestStr})) {
      $clusterP->{$newName}{$bestStr} = ();
    }
  }
  
  #Then find and add all kids Rx>y
  foreach my $y (sort keys %ylist) {
    my $newName = "R>$y";
    my $newNode = "$bestStr:$newName";
    foreach my $pos (sort keys %$clusterP) {
      if ($pos =~ /R.+>$y$/) {
        my @parts = split />/,$pos;
        if (scalar @parts !=2) {
          die "Error: class format error [$pos]";
        }
        if (exists $clusterP->{$pos}{$bestStr}) {
          my $kidNode = "$bestStr:$pos";
          print "HERE adding kids of\n";
          add_new_node($gtreeP,$newNode,$kidNode,$parts[0],$parts[1]);
        }
      }
    }
  }
}

#------------------------------------------------------------------------------

sub add_root_node($$) {
  my ($gtreeP,$root) = @_;
  $$gtreeP->add_vertex($root);
  $$gtreeP->set_attribute('vtype',$root,'standard');
  $$gtreeP->set_attribute('outcome',$root,'');
  $$gtreeP->set_attribute('rank',$root,0);
  $$gtreeP->set_attribute('left',$root,'');
  $$gtreeP->set_attribute('right',$root,'');
  $$gtreeP->set_attribute('count',$root,0);
  $$gtreeP->set_attribute('eg_str',$root,''); 
}

#------------------------------------------------------------------------------

sub refine_left($) {
  my ($gtreep)=@_;
  print "Entering refine_left\n" if $netDraw::debug; 
  my @vlist = $$gtreep->vertices();
  foreach my $v (@vlist) {
    next if $v eq '';
    my $keep=$v;
    my @parts = split /:/,$v;
    if (scalar @parts !=2) {
      die "Error: wrong node name format: $v\n";
    }
    my ($bestStr,$current) = @parts;
    my @cParts = split />/,$current;
    if (scalar @cParts !=2) {
      die "Error: wrong class format: $current\n";
    }
    
    my ($currentLeft,$currentRight)=@cParts;
    $currentLeft =~ s/R//;
    my $leftNum = length $currentLeft;
    my $rightNum = length $currentRight;
    my $bestNum = length $bestStr;
    
     if ($rightNum < $bestNum) {
      my $matchPart = substr($bestStr,0,$bestNum-$rightNum);
      my $newLeft = "R" . $matchPart . "&" . $currentLeft;
      $$gtreep->set_attribute('left',$v,$newLeft);
      print "Refined symbol found: [$keep][$newLeft]\n" if $netDraw::debug;
    }
  }
}

#------------------------------------------------------------------------------

sub add_class_counts($\%\%) {
  my ($gtreeP,$clusterP,$srcP)=@_;
    print "Entering add_class_counts\n" if $netDraw::debug; 
  my @allVertices = $$gtreeP->vertices();
  foreach my $v (@allVertices) {
    next if $v eq '';
    my @parts = split /:/,$v;
    if (scalar @parts != 2) {
      die "Error in node name format: [$v]\n";
    }
    my ($b,$c) = @parts;
    my @samples = keys %{$clusterP->{$c}{$b}};
    my $cnt = scalar @samples;
  
    $$gtreeP->set_attribute('count',$v,$cnt);
    my $eg_str="";
    my $num=0;
    foreach my $deriv (sort @samples) {
      my $example = $srcP->{$deriv};
      next if $example =~ /@/;   #Don't display apostrophe words for now -> they confuse dot
      $example =~ s/%/ /g;
      if ($num<3) {  
        $eg_str = " $eg_str | $example  \\l ";
        $num++;
      }
      #print "VERIFY:\t$example\n";
    }  
    $$gtreeP->set_attribute('eg_str',$v,$eg_str);
  }
}

#------------------------------------------------------------------------------

sub collapse_empty($) {
  my $gtreeP = shift @_;
  #Remove placeholder classes that only produce a single child
  #(Keep as empty if more than one child)
  print "Entering collapse_empty\n" if $netDraw::debug; 
  my @allVertices = $$gtreeP->vertices();
  foreach my $v (@allVertices) {
    next if $v eq '';
    my $cnt = get_count($gtreeP,$v);
    if ($cnt==0) {
      my @kids = $$gtreeP->successors($v);
      if (scalar @kids < 2) {
        print "Removing empty placeholder: $v\n" if $netDraw::debug;
        my @keepParents = $$gtreeP->predecessors($v);
        my @keepKids = $$gtreeP->successors($v);
        $$gtreeP->delete_vertex($v);
        foreach my $p (@keepParents) {
          foreach my $k (@keepKids) {
            $$gtreeP->add_edge($p,$k);
          }
        }
      }
    }
  }
}

#------------------------------------------------------------------------------

sub add_structure($) {
  my $gtreeP = shift @_;
  #Add structure to first layer of tree
  #based on "is contained in" relationships
  print "Entering add_structure\n" if $netDraw::debug; 
  my @topVertices = sort {length $b <=> length $a} $$gtreeP->successors('');
  my %done=();
  $done{''}=1;
  foreach my $vTo (@topVertices) {
    my $cTo = get_right($gtreeP,$vTo);
    my $mTo = $cTo;
    $mTo =~ s/^.*>//;
    next if exists $done{$mTo};
    foreach my $vFrom (@topVertices ) {
      my $cFrom = get_right($gtreeP,$vFrom);
      my $mFrom = $cFrom;
      $mFrom =~ s/^.*>//;
      next if exists $done{$mFrom};
      next if $mTo eq $mFrom;
      next if $mTo eq "se";
      if ($mTo =~ /$mFrom$/) {
        print "add_structure: Adding relationship: $mFrom -> $mTo ($vFrom -> $vTo)\n" if $netDraw::debug;
        $$gtreeP->add_edge($vFrom,$vTo);
        $$gtreeP->delete_edge('',$vTo);
        $done{$vTo}=1;
        last;
      }
    }
  }
}

#------------------------------------------------------------------------------

sub add_rank($) {
  my ($gtreeP) = shift @_;
  print "Entering add_rank\n" if $netDraw::debug;
  my %vertices = ();
  $vertices{''}= 1;
  my $rank = 0;
  while (scalar keys %vertices > 0) {
    my %new_roots=();
    foreach my $v (keys %vertices) {
      $$gtreeP->set_attribute('rank',$v,$rank);
      my @kids = $$gtreeP->successors($v);
      delete $vertices{$v};
      foreach my $k (@kids) {
        $vertices{$k}=1;
      }
    }
    $rank++;
  }
}

#------------------------------------------------------------------------------

sub update_mergeList(\%$$) {
  my ($listP,$old,$new) = @_;
  print "Entering update_mergeList [$old][$new]\n" if $netDraw::debug;
  foreach my $v (keys %{$listP}) {
    if ($v eq $old) {
      my $prevTarget = $listP->{$v};
      $listP->{$new} = $prevTarget;
      delete $listP->{$old};
      print "Info [update_mergeList]: $old -> $prevTarget changed to $new -> prevTarget\n" if $netDraw::debug;
    }
  }
  foreach my $v (keys %{$listP}) {
    if ($listP->{$v} eq $old) {
      next if $v eq $new;
      $listP->{$v} = $new;
      print "Info [update_mergeList]: $v -> $old changed to $v -> $new\n" if $netDraw::debug;
    }
  }
}

#------------------------------------------------------------------------------

sub change_str($$$) {
  my ($kid,$oldStr,$newStr)=@_;
  print "Entering change_str [$kid][$oldStr][$newStr]\n" if $netDraw::debug;
  my @kParts = split /:/,$kid;
  if (scalar @kParts != 2) {
    die "Error [change_str]: wrong format for node name [$kid]\n";
  }
  if (!($kParts[0] eq $oldStr)) {
    die "Error [change_str]: string mismatch for node [$kid][$oldStr]\n";
  }
  my $newKid = "$newStr:$kParts[1]";
  return $newKid;
}

#------------------------------------------------------------------------------

sub merge_same($\%) {
  my ($gtreeP,$clusterP) = @_;
  #Merge all nodes that have the same transformation rule
  #by adding the derivation list and children of a lower node to a higher node
  print "Entering merge_same\n" if $netDraw::debug;
  
  add_rank($gtreeP);
  
  #Create list of merges necessary (traverse tree top-down)
  my %prior=();
  my %mergeList=();
  my @vertices = sort { get_rank($gtreeP,$a) <=> get_rank($gtreeP,$b)} $$gtreeP->vertices();
  foreach my $v (@vertices) {
    my $outcome = get_outcome($gtreeP,$v);
    if (exists $prior{$outcome}) { 
      my $replace = $prior{$outcome};
      $mergeList{$v} = $replace;
    }
    $prior{$outcome}=$v;
  }

  #Merge from most specific to least specific (traverse tree bottom-up) 
    foreach my $v (sort {get_rank($gtreeP,$mergeList{$b}) <=> get_rank($gtreeP,$mergeList{$a})} keys %mergeList) {
    if (exists $mergeList{$v}) {
      my $replace = $mergeList{$v};
      my $rRank = get_rank($gtreeP,$replace);
      my $vRank = get_rank($gtreeP,$v);
      print "Info [merge_same]: add [$v] (rank $vRank) to [$replace] (rank $rRank) \n";
      my ($vStr,$vClass) = split /:/,$v;
      my ($rStr,$rClass) = split /:/,$replace;
      if (!($vClass eq $rClass)) {
        die "Error: class names do not match [$vClass] [$rClass]\n";
      }
      my @kids = $$gtreeP->successors($v);
      my @parents = $$gtreeP->predecessors($v);
      if (scalar @parents !=1) {
        die "Error: wrong number of parents [@parents] for node [$v]\n";
      }
      foreach my $k (@kids) {
        print "Info [merge_same]: merging a parent [$v] with kid [$k] of full set [@kids]\n";
        $$gtreeP->add_edge($replace,$k);
        $$gtreeP->delete_edge($v,$k);
        my $newKid = change_str($k,$vStr,$rStr);
        my %kList = ();
        $kList{$k}=1;
        while (scalar keys %kList>0) {
          foreach my $k (keys %kList) {
            my @moreKids = $$gtreeP->successors($k);
            update_name($gtreeP,$k,$newKid,$vStr,$rStr);
            update_mergeList(%mergeList,$k,$newKid);
            delete $kList{$k};
            foreach my $m (@moreKids) {
              print "Info: merging a grandparent [$v] with kid [k] and more kids [@moreKids]\n";
              $kList{$m}=1;
            }
          }
        }
      }
      
      foreach my $w (keys %{$clusterP->{$vClass}{$vStr}}) {
        delete $clusterP->{$vClass}{$vStr}{$w};
        $clusterP->{$rClass}{$rStr}{$w}=1;
      }
      delete $clusterP->{$vClass}{$vStr};
      $$gtreeP->delete_edge($parents[0],$v);
      $$gtreeP->delete_vertex($v);
      
      update_mergeList(%mergeList,$v,$replace);
    }
  }
}

#------------------------------------------------------------------------------

sub update_name($$$$$) {
  my ($gtreeP,$oldName,$newName,$oldStr,$newStr)=@_;
  print "Entering update_name [$oldName][$newName][$oldStr][$newStr]\n" if $netDraw::debug;
  my @parents = $$gtreeP->predecessors($oldName);
  my @kids = $$gtreeP->successors($oldName);
  $$gtreeP->add_vertex($newName);
  $$gtreeP->set_attribute('outcome',$newName,get_outcome($gtreeP,$oldName));
  $$gtreeP->set_attribute('rank',$newName,get_rank($gtreeP,$oldName));
  $$gtreeP->set_attribute('left',$newName,get_left($gtreeP,$oldName));
  $$gtreeP->set_attribute('right',$newName,get_right($gtreeP,$oldName));
  $$gtreeP->set_attribute('count',$newName,get_count($gtreeP,$oldName));
  $$gtreeP->set_attribute('eg_str',$newName,get_examples($gtreeP,$oldName));
  $$gtreeP->set_attribute('vtype',$newName,get_vtype($gtreeP,$oldName));
  foreach my $p (@parents) {
    $$gtreeP->add_edge($p,$newName);
    $$gtreeP->delete_edge($p,$oldName);
  }
    foreach my $k (@kids) {
    $$gtreeP->add_edge($newName,$k);
    $$gtreeP->delete_edge($oldName,$k);
  }
  $$gtreeP->delete_vertex($oldName);
}

#------------------------------------------------------------------------------

sub test_word_status($\%\%) {
  my ($gtreeP,$clusterP,$testWordsP)=@_;
  #Verify that the words in gtree and cluster remain constant
  #(and equal to testWords) throughout the process
  
  print "Entering test_word_status\n" if $netDraw::debug; 
  my @vertices = $$gtreeP->vertices();
  my %currentWords=();
  my %testWords=();
  foreach my $v (@vertices) {
    next if $v eq '';
    my ($b,$c) = split /:/,$v;
    foreach my $w (keys %{$clusterP->{$c}{$b}}) {
      $currentWords{$w}=1;
    }
  }
  foreach my $c (keys %{$testWordsP}) {
    foreach my $w (keys %{$testWordsP->{$c}}) {
      $testWords{$w}=1;
    }
  }

  my $numTest = scalar keys %testWords;
  my $numCurrent = scalar keys %currentWords;
  if ($numTest != $numCurrent) {
    print "Error: word lists out of sync\n";
    print "Words in test, but not in current:\n";
    foreach my $w (keys %testWords) {
      if (! exists $currentWords{$w}) {
        print "missing:\t$w\n";
      }
    }
    print "Words in current, but not in test:\n";
    foreach my $w (keys %currentWords) {
      if (! exists $testWords{$w}) {
        print "extra:\t$w\n";
      }
    }
  }
}

#------------------------------------------------------------------------------
# Net draw functions
#------------------------------------------------------------------------------

sub create_class_dotfile($$$) {
  my ($gtreep,$netName,$outName)=@_;
  print "Entering create_class_dotfile: $outName \n" if $netDraw::debug;
  $netName="";
  open OH, ">$outName" or die "Error writing to $outName\n";
  print OH "digraph G\n {\ncompound=true;\nlabel=\"$netName\";ranksep=\"0.7\"\n";
  #print OH "digraph G\n {\n";
  my @all_vertices = sort {get_rank($gtreep,$a)<=>get_rank($gtreep,$b)} $$gtreep->vertices();
  my $currentRank=0;
  my $num_rules = scalar @all_vertices;
  print "Tree for $netName: [$num_rules]\n";
  
  #printf OH "{ rank; \n";
  #foreach my $name  (@all_vertices) {
  #  my $nodeRank = get_rank($gtreep,$name);
  #  if ($nodeRank != $currentRank) {
  #    printf OH "}\n { rank =same; \n";
  #    $currentRank = $nodeRank
  #  }
  #  my $cLeft = get_left($gtreep,$name);
  #  my $cRight = get_right($gtreep,$name);
  #  my $col='white';
  #  my $thick=1;
  #  printf OH "\t\"%s\" [shape=record, label=\" %s | %s \",color=black,style=filled,fillcolor=%s,style=\"setlinewidth(%s)\"];\n",$name,$cLeft,$cRight,$col,$thick;
  #}
  #printf OH "}\n";
  
  while ((scalar @all_vertices)>0) {
    my $name = shift @all_vertices;
    my $vtype = get_vtype($gtreep,$name);
    my $col='white';
    my $thick=5;
    my $out='';
    my $cnt=0;
    my $eg_str='';
    my $cLeft="";
    my $cRight="";
    if ($vtype eq 'standard') {
      $out = get_outcome($gtreep,$name);
      $cnt = get_count($gtreep,$name);
      $eg_str = get_examples($gtreep,$name);
      if ($cnt<20) {
        $thick = '0.5';
      }elsif ($cnt<100) {
        $thick = '2';
      } else {
        $thick = '4';
      }
    } else {
      die "Unexpected type [$vtype]";
    }
    my @parts = split />/,$name;
     if (scalar @parts == 1) {
      #$cLeft = $parts[0];
      $cLeft = get_left($gtreep,$name);
      $cRight = "";
    } elsif (scalar @parts == 2) {
      #$cLeft = $parts[0];
      $cLeft = get_left($gtreep,$name);
      $cRight = $parts[1];
    } elsif ($name eq "") {
      #printf OH "\"\" [shape=record, label=\" PLACE X | NR  \",color=black,style=\"setlinewidth(%s)\",fontsize=22];\n",$thick;
      printf OH "\"\" [shape=record, label=\" PLACE X | ADJR  \",color=black,style=\"setlinewidth(%s)\",fontsize=22];\n",$thick;
      printf OH "\tsubgraph \"cluster_\" {label=\"\"; \"\"} \n";
      next;
    } else {
      die "Error: label not correctly formed: $out";
    }
    #$cLeft =~ s/R(.*)$/...\\{$1\\}/;
    if ($cLeft =~ /&/) {
      $cLeft =~ s/R(.*)&(.*)$/...$1\\{$2\\}/;
    } else {
      $cLeft =~ s/R(.*)$/...\\{$1\\}/;
    }
    $cLeft =~ s/%/ /;
    $cLeft =~ s/\\{\\}//;   #Delete braces if nothing removed
    
    printf OH "\t\"%s\" [shape=record, label=\" %s | %s \",color=black,style=filled,fillcolor=%s,style=\"setlinewidth(%s)\",fontsize=22];\n",$name,$cLeft,$cRight,$col,$thick;
    if (! ($vtype eq "container")) {
      if ($cnt>0) {
        printf OH "\t\"eg_%s\" [shape=record, label= \" { %d \\r %s } \",fontsize=16,fontname=\"Times-Italic\",style=\"setlinewidth(0)\"]\n",$name,$cnt,$eg_str;
        #printf OH "\t\"%s\" -> \"eg_%s\" [label=\"%s\",color=white,weight=100]\n",$name,$name,$name;
        printf OH "\t\"%s\" -> \"eg_%s\" [label=\"\",color=white,weight=100]\n",$name,$name;
        printf OH "\tsubgraph \"cluster_%s\" {label=\"\"; \"%s\"; \"eg_%s\"} \n", $name,$name,$name;
      } else {
        printf OH "\tsubgraph \"cluster_%s\" {label=\"\"; \"%s\"} \n", $name,$name;
      }
    }  
  }
  
  my @all_edges = $$gtreep->edges();
  while ((scalar @all_edges)>0) {
    my $v1 = shift @all_edges;
    my $v2 = shift @all_edges;
    if (($v1 eq "")||($v1 eq "iër:R>iër")||($v1 eq "iese:R>iese")) {   #HACK: final drawing prior to submitting article...
      print OH "\t\"$v1\" -> \"$v2\" [color=black,ltail=\"cluster_$v1\",lhead=\"cluster_$v2\",weight=1];\n";
    } else {
      print OH "\t\"eg_$v1\" -> \"$v2\" [color=black,ltail=\"cluster_$v1\",lhead=\"cluster_$v2\",weight=1];\n";
    }
  }
  #HACK: final drawing prior to submitting article...
  #print OH "{ rank=same; \"er:R>r\"; \"iër:Ra>iër\"; \"ner:R>ner\" }\n";
  #print OH "}\n";
  close OH;
}

#------------------------------------------------------------------------------

sub create_rule_dotfile($$\%$) {
  my ($gtreep,$netName,$colourP, $outName)=@_;
  open OH, ">$outName" or die "Error writing to $outName\n";
  print OH "digraph G\n {\nlabel=\"$netName\"\n";
  #print OH "digraph G\n {\n";
  my @all_vertices =$$gtreep->vertices();
  my $num_rules = scalar @all_vertices;
  print "Tree for $netName: [$num_rules]\n";
  while ((scalar @all_vertices)>0) {
    my $name = shift @all_vertices;
    my $left = get_left($gtreep,$name);
    my $vtype = get_vtype($gtreep,$name);
    my $label='';
    my $col='white';
    my $out = get_outcome($gtreep,$name);
    my $cnt = get_count($gtreep,$name);
    my @levels = sort {$a <=> $b} keys %$colourP;
    foreach my $l (@levels) {
      if ($cnt>=$l) {
        $col = $colourP->{$l}
      }
    }
    $out =~ s/R(.*)>(.*)$/[ {$1} ] [ $2 ]/;
    $out =~ s/{} //g;
    $out =~ s/%/ /g;
    $left =~ s/%/ /g;
    $label = "-$left\\n$out\\n$cnt";
    printf OH "\t\"%s\" [label=\"%s\",color=black,style=filled,fillcolor=%s];\n",$name,$label,$col;
    #printf OH "\t\"%s_examples\" [label=\"asdf\",color=black,style=\"setlinewidth(0)\"];\n",$name;
  }
  
  my @all_edges = $$gtreep->edges();
  while ((scalar @all_edges)>0) {
    my $v1 = shift @all_edges;
    my $v2 = shift @all_edges;
    print OH "\t\"$v1\" -> \"$v2\" [color=red];\n";
  }
  print OH "}\n";
  close OH;
}

#------------------------------------------------------------------------------
# Main functionality
#------------------------------------------------------------------------------

sub fdraw_rule_net($$$\%$$) {
  my ($rulesName, $symbolsName, $infoName, $colourP, $ext, $outName)=@_;
  print "Entering fdraw_rule_net: [$rulesName][$symbolsName][$infoName][$outName]\n" if $netDraw::debug; 
  my $gtree = Graph->new(compat02 => 1);    #TODO: move to new 05 features throughout code; 02 support limited
  $gtree->directed(1);
  my $cnt=0;
  $cnt=fread_rules_net($rulesName,$symbolsName,\$gtree);
  update_type(\$gtree,'rule');
  if ($cnt>0) {
    add_rule_counts($infoName,\$gtree);
    my $textFile = "$outName.dot";
    my $imageFile = "$outName.$ext";
    create_rule_dotfile(\$gtree,"Rule-based network",%$colourP, $textFile);
    system "dot -T$ext $textFile -o $imageFile";
  }
}

#------------------------------------------------------------------------------

sub read_derivations($\%\%) {
  my ($infoName,$derivP,$srcP)=@_;
  #Read derivations in format: $derivP->{class}{derivation}
  open IH, "$infoName" or die "Error opening $infoName\n";
  %{$derivP}=();
  while (<IH>) {
    chomp;
    my @parts = split /\t/,$_;
    if (scalar @parts != 3) {
      die "Error in info file format. File: $infoName, Line: $_\n";
    } else {
      my ($word,$c,$deriv)=@parts;
      $derivP->{$c}{$deriv}=1;
      $srcP->{$deriv} = $word;
    }
  }
  close IH;
}

#------------------------------------------------------------------------------

sub fdraw_class($$$) {
  my ($gtreep,$ext,$outName) = @_;
  my $textFile = "$outName.dot";
  my $imageFile = "$outName.$ext";
  create_class_dotfile($gtreep,"Class-based network",$textFile);
  system "dot -T$ext $textFile -o $imageFile";
}

#------------------------------------------------------------------------------

sub fdraw_class_net($$$$) {
  my ($symbolsName,$infoName,$ext,$outName)=@_;
  print "Entering fdraw_class_net: [$symbolsName][$infoName][$outName]\n" if $netDraw::debug;
  my %derivations=();   
  my %clusters=();
  my %srcWords=();
  my %bestStrings=();
  
  # Read class information
  read_derivations($infoName,%derivations,%srcWords);
  
  # Create main nodes of network by identifying the best strings and create the structure $clusterP->{class}{bestStr}{deriv}
  # Also keep track of  best string list in %bestStrings.
  # step 1-6 in 2010 paper: 
  create_clusters(%derivations,%clusters,%bestStrings);
  
  # Now order the best strings in a tree structure  
  my $gtree = Graph->new(compat02 => 1);    #TODO: move to new 05 features throughout code; 02 support limited
  $gtree->directed(1);
  add_root_node(\$gtree,'');
 
  #step 7: add branches one by one
  foreach my $b (keys %bestStrings) {
    my %buildList = ();
    foreach  my $c (keys %clusters) {
      if (exists $clusters{$c}{$b}) {
        $buildList{$c}=1;
      }
    }
    add_branch(\$gtree,$b,%buildList,%clusters);
  }
  test_word_status(\$gtree,%clusters,%derivations);
  
  # determine depth of each node
  add_rank(\$gtree);
  fdraw_class(\$gtree,$ext,"$outName.0");
  
  # add additional information for display purposes
  add_class_counts(\$gtree,%clusters,%srcWords);
  fdraw_class(\$gtree,$ext,"$outName.1"); 
  collapse_empty(\$gtree);
  fdraw_class(\$gtree,$ext,"$outName.2");
  
  # step 8
  add_structure(\$gtree); 
  fdraw_class(\$gtree,$ext,"$outName.3");
  
  # step 9
  merge_same(\$gtree,%clusters);
  add_class_counts(\$gtree,%clusters,%srcWords);
  fdraw_class(\$gtree,$ext,"$outName.4");
  collapse_empty(\$gtree);
  fdraw_class(\$gtree,$ext,"$outName.5");
  
  # step 10
  refine_left(\$gtree);
  fdraw_class(\$gtree,$ext,"$outName.6");
}

#--------------------------------------------------------------------------
# Not explicitly called, useful during debugging
#--------------------------------------------------------------------------

#Write rules in order based on current tree
sub traverse_net($$) {
  my ($gtreep,$fname) = @_;
  print "Entering traverse_net \n" if $netDraw::debug;    
  open OH, ">$fname" or die "Error opening $fname\n";
  my @vlist=$$gtreep->toposort();
  my $i=1;
  my @rlist=();
  foreach my $v (@vlist) {
    my $vout = get_outcome($gtreep,$v);
    print OH "[$i] $v";
    print OH " -> $vout\n";
    $i++;
    unshift @rlist,$v;
  }
  close OH;
}

#--------------------------------------------------------------------------

sub get_leaves($$\%\%) {
  my ($gtreep,$root,$leavesP,$pathsP)=@_;
  print "Entering get_leaves: [$root]\n" if $netDraw::debug;
  %$leavesP = ();
  %$pathsP = ();
  $leavesP->{$root}=1;
  $pathsP->{$root}=$root;
  my $busy=1;
  while ($busy) {
    my @pos_leaves = keys %$leavesP;
    $busy=0;
    foreach my $l (@pos_leaves) {
      my @new_leaves = $$gtreep->successors($l);
      if (scalar @new_leaves !=0) {
        delete $leavesP->{$l};
        foreach my $n (@new_leaves) {
          $leavesP->{$n}=1;
          $pathsP->{$n}= sprintf("%s:%s",$pathsP->{$l},$n);
        }
        $busy=1;
      }
    }
  }
  my @leavelist = sort keys %$leavesP;
  print "Leaving get_leaves: [@leavelist]\n" if $netDraw::debug;
}

#--------------------------------------------------------------------------

sub is_child_of($$$) {
  my ($gtreep,$parent,$child) = @_;
  my @list = $$gtreep->successors($parent);
  foreach my $l (@list) {
    if ($child eq $l) {
      return 1;
    }
  }
  return 0;
}

#--------------------------------------------------------------------------

return 1;

END { }

#--------------------------------------------------------------------------
